home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Franz PD
/
Franz PD Disk #119 (1991-03)(Amiga User Group Deutschland e.V.).zip
/
Franz PD Disk #119 (1991-03)(Amiga User Group Deutschland e.V.).adf
/
AmigaBASIC_Programme
/
Tortengrafik
(
.txt
)
< prev
next >
Wrap
AmigaBASIC Source Code
|
1989-07-03
|
8KB
|
163 lines
' *** 3D-Tortengrafik 1.4 *** © 1990 by Michael Gottwald
DIM Norm%(1),Netz%(1),Schraffur1%(15),Schraffur2%(15),Punkte%(3)
DIM Punkte2%(3),Punkte3%(3),Punkte4%(3),Punkte5%(3),Streifen%(1)
DIM Balken%(1),Netz2%(3):Norm%(0)=&Hffff:Norm%(1)=&Hffff
Netz%(0)=&Haaaa:Netz%(1)=&H5555:FOR i%=0 TO 15:READ d%:Schraffur1%(i%)=d%
Schraffur2%(15-i%)=d%:NEXT:Punkte%(0)=&H9248:Punkte%(2)=&H4924
Punkte2%(1)=&H9248:Punkte3%(0)=&H8208:Punkte3%(3)=&H1041
Punkte4%(0)=&H8010:Punkte4%(3)=&H801:Punkte5%(1)=&H800:Punkte5%(2)=8
Streifen%(0)=&Haaaa:Streifen%(1)=&Haaaa:Balken%(0)=&Hffff
Netz2%(0)=&Haaaa:Netz2%(2)=&H5555
x=150:y=74:c=3:c2=2:a=2
t$="MedRes 1 640x242 , 6 Farben + 4 Muster":Text
y=94:t$="MedRes 2 640x242 , 14 Farben + 4 Muster":Text
y=114:t$="Hires 1 640x498 , 6 Farben + 4 Muster":Text
y=134:t$="Hires 2 640x498 , 14 Farben + 4 Muster":Text
y=154:t$="Monochrom 1 640x242 , 1 Farbe + 12 Muster":Text
y=174:t$="Monochrom 2 640x498 , 1 Farbe + 12 Muster":Text
FOR y%=63 TO 163 STEP 20:LINE (100,y%)-(100,y%+16),1:LINE -(140,y%+16),2
LINE -(140,y%),2:LINE -(100,y%),1:NEXT:LOCATE 28,2:COLOR 2,0
PRINT "Monochrom 1/2 ist für eine Hardcopy mit einem S/W-Drucker ";
PRINT "am sinnvollsten !"
Gadgets: CALL Maus (x,y):IF x<100 OR x>140 THEN Gadgets
IF y>62 AND y<79 THEN Hoehe=242:Tiefe=3:Modus=2:q=30:GOTO Haupt
IF y>82 AND y<99 THEN Hoehe=242:Tiefe=4:Modus=2:q=70:GOTO Haupt
IF y>102 AND y<119 THEN Hoehe=498:Tiefe=3:Modus=4:q=30:GOTO Haupt
IF y>122 AND y<139 THEN Hoehe=498:Tiefe=4:Modus=4:q=70:GOTO Haupt
IF y>142 AND y<159 THEN Hoehe=242:Tiefe=3:Modus=2:q=12:GOTO Haupt
IF y>162 AND y<179 THEN Hoehe=498:Tiefe=3:Modus=4:q=12:GOTO Haupt
GOTO Gadgets
Haupt: SCREEN 1,640,Hoehe+14,Tiefe,Modus
w$=SPACE$(26)+"© 199O by Michael Gottwald":WINDOW 1,w$,(0,0)-(630,Hoehe),4,1
WINDOW 1
PALETTE 0,0,0.6,0.7:PALETTE 1,0,0,0:PALETTE 2,0.8,0.8,0:PALETTE 3,0,1,0
PALETTE 4,1,0,0:PALETTE 5,0,0,1:PALETTE 6,1,0,1:PALETTE 7,1,1,1
DIM p(70),w$(70),c(70,5)
Start: COLOR ,0:CLS:LOCATE 2,30:a=2:x=252:y=12:c=2:c2=0:t$="3D-Tortengrafik"
CALL Text:LOCATE 6,3:COLOR 1,0:LINE (244,4)-(244,16),7
LINE -(380,16),1:LINE -(380,4),1:LINE -(244,4),7:x=16:y=60:c=3
LINE (240,2)-(240,18),7:LINE -(384,18),1:LINE -(384,2),1:LINE -(240,2),7
t$="Dieses Programm erzeugt eine dreidimensionale Tortengrafik.":CALL Text
y=y+10:t$="Es kann bis zu 70 verschiedene Segmente einer Scheibe nach"
t$=t$+" prozentualer":CALL Text:y=y+10:t$="Einteilung zeichnen.":CALL Text
y=y+50:x=176:a=1:c=4:t$="© 199O written by Michael Gottwald"
CALL Text:LINE (128,120)-(128,136),1:LINE -(496,136),7:LINE -(496,120),7
LINE -(128,120),1:y=y+50:x=196:c=5
t$="...Linke Maustaste drücken...":CALL Text:WHILE MOUSE(0)=0:WEND
Frage: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0:s=0:pi=5.30795e-315
t$="(P)rozentwerte oder (B)eliebige Zahlen ? ":Text
INPUT f$:f$=UCASE$(f$):IF f$="P" THEN Prozente
IF f$="B" THEN Beliebig
GOTO Frage
Beliebig: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0
t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
t$=" 0 = Ende !":LOCATE 8:COLOR 3
BelZahl: GOSUB Eingabe:z=z+1:IF z>q THEN PRINT"Zuviel Zahlen !":GOTO Beliebig
s=s+x:p(z)=x:IF x<>0 THEN BelZahl
z=z-1:PRINT:INPUT "Was soll hinter einer Zahl stehen ";k$:GOTO Torte
Prozente: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2
t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
t$="Die Summe aller darf 100 natürlich nicht überschreiten !":CALL Text
y=y+10:t$="0 = Ende !":CALL Text:LOCATE 8:COLOR 3
ProzZahl: GOSUB Eingabe:IF x+s=100 THEN s=s+x:p(z)=x:z=z+1:k$="%":GOTO Torte
IF x=0 OR s+x>100 OR x>100 THEN ProzZahl
s=s+x:p(z)=x:z=z+1:IF z<q THEN ProzZahl
Eingabe: PRINT " Zahl Nr."z+1;": (Summe bisher:"s;:IF f$="P" THEN PRINT"%";
PRINT ")";
Wort: INPUT " ";x:COLOR 5:INPUT "Text dazu (max. 10 Zeichen): ",w$(z)
IF LEN(w$(z))>10 THEN Wort :ELSE COLOR 3:RETURN
Torte: IF q=12 THEN
SCREEN 1,640,256,1,Modus:WINDOW 1,w$,(0,0)-(630,Hoehe),4,1
WINDOW 1:PALETTE 0,1,1,1:PALETTE 1,0,0,0
END IF
CLS:z=z-1:CIRCLE (320,120),200,1,pi,2*pi,0.2:LINE (120,100)-(120,120),1
LINE (520,100)-(520,120),1:CIRCLE (320,100),200,1,,,0.2
sw=0:c=1:PATTERN &Hffff,Norm%:FOR i=0 TO z
IF q=12 THEN
c=1:ON i GOTO M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,12
END IF
IF q=30 THEN IF (i+1)/7=INT((i+1)/7) THEN c=1:Nr=(i+1)/7:GOTO Muster
IF q=70 THEN IF (i+1)/15=INT((i+1)/15) THEN c=1:Nr=(i+1)/15:GOTO Muster
GOTO Seg
Muster: ON Nr GOTO M1,M4,M5,M6
Seg: GOSUB Segment:c=c+1:NEXT:PATTERN &H71ce
a=2:FOR i=0 TO z:c=7:LINE (c(i,0),c(i,1))-(c(i,2),c(i,3)),1
y=c(i,3):IF y>c(i,1) THEN y=y-5
t$=w$(i):IF c(i,2)<c(i,0) THEN
x=(c(i,2)-(LEN(w$(i))*8))
IF q=12 THEN CALL MText :ELSE CALL Text
GOTO Ok
END IF
x=c(i,2):IF q=12 THEN CALL MText :ELSE CALL Text
Ok: y=y+10:x=x-8:IF c(i,2)<c(i,0) THEN x=x+8-LEN(k$)*8
c=2:t$=STR$(p(i))+k$:IF q=12 THEN CALL MText :ELSE CALL Text
NEXT:PATTERN &Hffff,Norm%:GOTO Gadget
Segment:
IF f$="B" THEN p=(p(i)/s)*100 :ELSE p=p(i)
w=sw+(360*p/100):ew=w*pi/180:fs=sw:sw=sw*pi/180:z1=320+SIN(sw)*200
z2=100+COS(sw)*40:z3=320+SIN(ew)*200:z4=100+COS(ew)*40
LINE (320,100)-(z1,z2),1:LINE (320,100)-(z3,z4),1
M=(ew-sw)/2:M=ew-M:PAINT (320+SIN(M)*198,100+COS(M)*38),c,1
f=0:ff=0:IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN f=1
IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN ff=1
IF f=1 OR ff=1 THEN GOSUB Front
a=sw+0.5*(ew-sw):sw=w
c(i,0)=320+SIN(a)*180:c(i,1)=100+COS(a)*30
c(i,2)=320+SIN(a)*235:c(i,3)=100+COS(a)*80
IF a>1.56 AND a<4.72 THEN c(i,3)=100+COS(a)*60
RETURN
Front: IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN LINE (z3,z4)-(z3,z4+20),1
IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN LINE (z1,z2)-(z1,z2+20),1
IF f=1 THEN GOSUB Sangle
IF ff=1 THEN GOSUB Eangle
RETURN
Sangle: PAINT (z1+1,z2+1),c,1:RETURN
Eangle: PAINT (z3-1,z4+1),c,1:RETURN
Gadget: c1=7:c2=1:ct1=3:ct2=4:IF q=12 THEN c1=1
x=28:y=14:a=1:c=ct2:t$="Ende":IF q=12 THEN CALL MText :ELSE CALL Text
LINE (20,4)-(20,20),c1:LINE -(68,20),c2:LINE -(68,4),1
LINE -(20,4),c1:y=34:x=16:c=ct1:t$="Nochmal":LINE (8,24)-(8,40),c1
IF q=12 THEN CALL MText :ELSE CALL Text
LINE -(79,40),c2:LINE -(79,24),c2:LINE -(8,24),c1
check: CALL Maus (x,y):IF x>19 AND x<69 AND y>3 AND y<21 THEN LOCATE 10:END
IF x>7 AND x<80 AND y>23 AND y<41 AND q=12 THEN RUN
IF x>7 AND x<80 AND y>23 AND y<41 THEN Start
GOTO check
SUB Text STATIC
SHARED x,y,c,c2,a,t$ ' a ist der x-Abstand des Schattens
POKEW WINDOW(8)+38,y+1:COLOR c2,0:PRINT PTAB(x+a);t$:POKE WINDOW(8)+28,0
POKEW WINDOW(8)+38,y:COLOR c:PRINT PTAB(x);t$:POKE WINDOW(8)+28,1
END SUB
SUB Maus (x,y) STATIC
WHILE MOUSE(0)=0:WEND:x=MOUSE(3):y=MOUSE(4):WHILE MOUSE(0)<>0:WEND
END SUB
SUB MText STATIC ' Füür Monochrom-Modus...
SHARED x,y,t$
POKEW WINDOW(8)+38,y:COLOR 1:PRINT PTAB(x);t$
END SUB
'Schraffur 1:
DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492
DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492
DATA &H9249,&H4924,&H2492,&H9249
M1: PATTERN ,Netz%:GOTO Seg
M2: PATTERN ,Streifen%:GOTO Seg
M3: PATTERN ,Balken%:GOTO Seg
M4: PATTERN ,Schraffur1%:GOTO Seg
M5: PATTERN ,Schraffur2%:GOTO Seg
M6: PATTERN ,Netz2%:GOTO Seg
M7: PATTERN ,Punkte%:GOTO Seg
M8: PATTERN ,Punkte2%:GOTO Seg
M9: PATTERN ,Punkte3%:GOTO Seg
M10: PATTERN ,Punkte4%:GOTO Seg
M11: PATTERN ,Punkte5%:GOTO Seg